home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / library.tcl < prev    next >
Encoding:
Text File  |  2001-01-29  |  16.1 KB  |  499 lines
  1. # Should rename this to alphaIndices.tcl or something like that.
  2.  
  3. # Clean up temporary files:
  4. proc removeTemporaryFiles {} {
  5.     global PREFS
  6.     if {[file exists [file join $PREFS tmp]]} {
  7.     foreach f [glob -dir [file join $PREFS tmp] -nocomplain *] {
  8.         message "removing [file tail $f]…"
  9.         file delete $f
  10.     }
  11.     }
  12.     message "all temporary files removed"
  13. }
  14.  
  15. set alpha::rebuilding 0
  16.  
  17. proc alpha::rebuildPackageIndices {} {
  18.     alpha::makeIndices
  19.     message "Indices and package menu rebuilt."
  20. }
  21.  
  22. proc alpha::makeIndices {} {
  23.     # add all new directories to the auto_path
  24.     alpha::makeAutoPath
  25.     # ensure count is correctly set - otherwise we'd probably have to
  26.     # rebuild next time we started up.
  27.     alpha::rectifyPackageCount
  28.     set types {index::feature index::mode index::uninstall index::preinit index::maintainer index::description index::help index::disable index::flags}
  29.     global pkg_file HOME alpha::rebuilding alpha::version \
  30.       index::oldmode alpha::tclversion
  31.     eval global $types
  32.     # Remember those packages which have already had their 'one-time init' called.
  33.     foreach pkg [array names index::feature] {
  34.     if {[llength [set index::feature($pkg)]] > 3} {
  35.         if {![string length [lindex [set index::feature($pkg)] 3]]} {
  36.         # It was activated at some point, or has < 4 elements.
  37.         lappend already_activated $pkg
  38.         }
  39.     }
  40.     }
  41.     # Remember the old feature array, so we can re-instantiate mode-menus
  42.     # which otherwise disappear from the array.
  43.     array set feature_temp [array get index::feature]
  44.     # store old mode information so we can check what changed
  45.     catch {cache::readContents index::mode}
  46.     catch {array set index::oldmode [array get index::mode]}
  47.     
  48.     catch {eval cache::delete $types}
  49.     foreach type $types {
  50.     catch {unset $type}
  51.     }
  52.     foreach dir [list SystemCode Modes Menus Packages] {
  53.     lappend dirs [file join ${HOME} Tcl ${dir}]
  54.     eval lappend dirs [glob -types d -dir [file join ${HOME} Tcl ${dir}] -nocomplain *]
  55.     }
  56.     if {[file exists [file join ${HOME} AlphaCore]]} {
  57.     lappend dirs [file join ${HOME} AlphaCore]
  58.     }
  59.     set alpha::rebuilding 1
  60.     
  61.     # provide the 'Alpha' and 'AlphaTcl' packages
  62.     ;alpha::extension Alpha ${alpha::version} {} help {file "Alpha Manual"}
  63.     ;alpha::extension AlphaTcl ${alpha::tclversion} {} help {file "Extending Alpha"}
  64.     # declare 2 different scan contexts:
  65.     set cid_scan [scancontext create]
  66.     scanmatch $cid_scan "^\[ \t\]*alpha::(declare|menu|mode|flag|extension|feature|package\[ \t\]+(uninstall|disable|maintainer|help))\[ \t\\\\\]" {
  67.     incr rebuild_cmd_count 1
  68.     }
  69.     scanmatch $cid_scan "^\[ \t\]*newPref\[ \t\]" {
  70.     if {[incr numprefs] == 1} {
  71.         set newpref_start $matchInfo(offset)
  72.     }
  73.     }
  74.     set cid_help [scancontext create]
  75.     scanmatch $cid_help "^\[ \t\]*#" {
  76.     if {[expr {$linenum +1}] != $matchInfo(linenum)} { set hhelp "" }
  77.     append hhelp [string trimleft $matchInfo(line) " \t#"] " "
  78.     set linenum $matchInfo(linenum)
  79.     }
  80.  
  81.     scanmatch $cid_help "^\[ \t\]*newPref\[ \t\]" {
  82.     if {[expr {$linenum +1}] == $matchInfo(linenum)} {
  83.         if {$hhelp != ""} {
  84.         set got $matchInfo(line)
  85.         # While the line either ends in a continuation backslash,
  86.         # or has an unmatched brace:
  87.         while {![info complete "${got}\n"]} {
  88.             append got [gets $matchInfo(handle)]
  89.             if {[eof $matchInfo(handle)]} {break}
  90.         }
  91.         # Tcl really ought to supply us with a built-in 'parseWords'
  92.         if {[catch {parseWords $got} res]} {
  93.             if {[askyesno "Had a problem extracting preferences help information\
  94.               from '$got'.  View error?"] == "yes"} {
  95.             alertnote [string range $res 0 240]
  96.             error "problem"
  97.             }
  98.         }
  99.         set pkg [lindex $res 4]
  100.         set var [lindex $res 2]
  101.         # allow comment to over-ride the mode/package
  102.         regexp "^\\((\\w+)\\)\[ \t\]*(.*)\$" $hhelp "" pkg hhelp
  103.         if {$pkg == "" || $pkg == "global"} {
  104.             set prefshelp($var) $hhelp
  105.         } else {
  106.             set prefshelp($pkg,$var) $hhelp
  107.         }
  108.         }
  109.     }
  110.     set hhelp ""
  111.     if {[incr numprefs -1] == 0} {
  112.         error "done"
  113.     }
  114.     }
  115.     
  116.     global rebuild_cmd_count
  117.     foreach d $dirs {
  118.     foreach f [glob -nocomplain -dir $d *.tcl] {
  119.         if {![catch {alphaOpen $f} fid]} {
  120.         message "scanning [file tail $f]…"
  121.         set numprefs 0
  122.         set rebuild_cmd_count 0
  123.         # check for 'newPref' or 'alpha::package' statements
  124.         scanfile $cid_scan $fid
  125.         if {$numprefs > 0} {
  126.             message "scanning [file tail $f]…($numprefs prefs)"
  127.             incr newpref_start -520
  128.             seek $fid [expr {$newpref_start > 0 ? $newpref_start : 0}]
  129.             set linenum -2
  130.             set hhelp ""
  131.             if {[catch [list scanfile $cid_help $fid] err]} {
  132.             if {$err != "done"} {
  133.                 if {[askyesno "Had a problem extracting preferences help information\
  134.                   from '[file tail $f]'.  View error?"] == "yes"} {
  135.                 alertnote [string range $err 0 240]
  136.                 }
  137.             }
  138.             }
  139.         }
  140.         close $fid
  141.         if {$rebuild_cmd_count > 0} {
  142.             message "scanning [file tail $f] for packages"
  143.             set pkg_file $f
  144.             if {[catch {uplevel \#0 [list source $f]} res] != 11} {
  145.             if {[askyesno "Had a problem extracting package information from [file tail $f].  View error?"] == "yes"} {
  146.                 alertnote [string range $res 0 240]
  147.             }
  148.             }
  149.         }
  150.         }
  151.     }
  152.     }
  153.     catch {unset rebuild_cmd_count}
  154.     set alpha::rebuilding 0
  155.     
  156.     scancontext delete $cid_scan
  157.     scancontext delete $cid_help
  158.     cache::create index::prefshelp variable prefshelp
  159.     
  160.     foreach type $types {
  161.     cache::add $type "variable" $type
  162.     if {($type != "index::feature") && ($type != "index::flags")} { catch {unset $type} }
  163.     }
  164.     catch {unset index::oldmode}
  165.     catch {unset pkg_file}
  166.     #foreach n [array names index::feature] {}
  167.     global alpha::requirements
  168.     if {[info exists alpha::requirements]} {
  169.     foreach itm ${alpha::requirements} {
  170.         set m [lindex $itm 0]
  171.         set req [lindex $itm 1]
  172.         if {[catch {package::versionCheck [lindex $req 0] [lindex $req 2]} err]} {
  173.         alertnote "$m mode requirements failure: $err  You should upgrade that package."
  174.         }
  175.     }
  176.     }
  177.     
  178.     # Re-initialise those features which were created on the fly.
  179.     # If we completely deleted some packages, their information will be recreated here,
  180.     # until the next time you quit Alpha.
  181.     foreach pkg [array names feature_temp] {
  182.     if {![info exists index::feature($pkg)]} {
  183.         set index::feature($pkg) $feature_temp($pkg)
  184.     }
  185.     }
  186.     
  187.     # Clear the 'one-time init' script for those packages which already had it cleared.
  188.     if {[info exists already_activated]} {
  189.     foreach pkg $already_activated {
  190.         if {[info exists index::feature($pkg)]} {
  191.         if {[llength [set index::feature($pkg)]] > 3} {
  192.             set index::feature($pkg) [lreplace [set index::feature($pkg)] 3 3 ""]
  193.         }
  194.         }
  195.     }
  196.     }
  197.  
  198.     message "Package index rebuilt."
  199. }
  200.  
  201. proc alpha::reportError {string} {
  202.     global reportErrors errorInfo
  203.     if {$reportErrors} {
  204.     set errorCache $errorInfo
  205.     if {[dialog::yesno -y "View the error" -n "Continue" \
  206.       $string]} {
  207.         dialog::alert $errorCache
  208.     }
  209.     } else {
  210.     global alpha::errorLog
  211.     append alpha::errorLog $string
  212.     }
  213. }
  214.  
  215. proc userMessage {{alerts 1} {message ""}} {
  216.     if {$alerts} {
  217.     alertnote $message
  218.     } else {
  219.     message $message
  220.     }
  221. }
  222.  
  223. namespace eval flag {}
  224.  
  225. # Always use this proc, don't mess with 'flag::types' directly.
  226. proc flag::addType {type} {
  227.     global flag::types
  228.     if {[lsearch -exact ${flag::types} $type] == -1} {
  229.     lappend flag::types $type
  230.     }
  231. }
  232.  
  233. # Declare basic preference types
  234. namespace eval flag {}
  235. set flag::types [list "flag" "variable" "binding" "menubinding" \
  236.   "file" "io-file" "funnyChars" "url"]
  237. # Note: other types are triggered by vars ending in 'Colour', 'Color',
  238. # 'Folder', 'Path', 'Mode', 'Sig', or 'SearchPath'
  239.  
  240. namespace eval global {}
  241.  
  242. ## 
  243.  # -------------------------------------------------------------------------
  244.  # 
  245.  # "newPref" --
  246.  # 
  247.  #  Define a new preference variable/flag.  You can call this procedure
  248.  #  either with multiple arguments or with a single list of all the
  249.  #  arguments.  So 'newPref flag Hey ...' or 'newPref {flag Hey ...}'
  250.  #  are both fine.
  251.  #  
  252.  #  'type' is one of:
  253.  #    'flag' (on/off only), 'variable' (anything), 'binding' (key-combo)
  254.  #    'menubinding' (key-combo which works in a menu), 'file' (input only),
  255.  #    'io-file' (either input or output).  Variables whose name ends in
  256.  #    Sig, Folder, Path, Mode, Colour, Color or SearchPath (case matters here) 
  257.  #    are treated differently, but are still considered of type 'variable'.
  258.  #    For convenience this proc will map types sig, folder, color, ...
  259.  #    into 'variable' for you, _if_ the variable ends with the correct
  260.  #    string.
  261.  #    
  262.  #  'name' is the var name, 
  263.  #  
  264.  #  'val' is its default value (which will be ignored if the variable
  265.  #  already has a value)
  266.  #  
  267.  #  'pkg' is either 'global' to mean a global preference, or the name 
  268.  #  of the mode or package (no spaces) for which this is a preference.
  269.  #  
  270.  #  'pname' is a procedure to call if this preference is changed by
  271.  #  the user (no need to setup a trace).  This proc is only called
  272.  #  for changes made through prefs dialogs or prefs menus created by
  273.  #  Alpha's core procs.  Other changes are not traced.
  274.  #  
  275.  #  Depending on the previous values, there are two optional arguments
  276.  #  with the following uses:
  277.  #  
  278.  #  TYPE:
  279.  #  
  280.  #  variable:
  281.  #  
  282.  #  'options' is a list of items from which this preference takes a single
  283.  #  item.
  284.  #  'subopt' is any of 'item', 'index', 'varitem' or 'varindex' or 'array', where
  285.  #  'item' indicates the pref is simply an item from the given list
  286.  #  of items, 'index' indicates it is an index into that list, and
  287.  #  'var*' indicates 'items' is in fact the name of a global variable
  288.  #  which contains the list. 'array' means take one of the values from an array.
  289.  #  If no value is given, 'item' is the default
  290.  #  
  291.  #  binding:
  292.  #  
  293.  #  'options' is the name of a proc to which this item should be bound.
  294.  #  If options = '1', then we Bind to the proc with the same name as
  295.  #  this variable.  Otherwise we do not perform automatic bindings.
  296.  #  
  297.  #  'subopt' indicates whether the binding is mode-specific or global.
  298.  #  It should either be 'global' or the name of a mode.  If not given,
  299.  #  it defaults to 'global' for all non-modes, and to mode-specific for
  300.  #  all packages.  (Alpha tests if something is a mode by 'mode::exists')
  301.  # -------------------------------------------------------------------------
  302.  ##
  303. proc newPref {vtype {name {}} {val 0} {pkg "global"} {pname ""} {options ""} {subopt ""}} {
  304.     if {$name == {}} { uplevel 1 newPref $vtype}
  305.     
  306.     global allFlags allVars tclvars modeVars flag::procs \
  307.       flag::type flag::types alpha::earlyPrefs
  308.     # 'link' means link this variable with Alpha's internals.
  309.     if {[regexp {^early(.*)$} $vtype "" vtype]} {
  310.     lappend alpha::earlyPrefs $name
  311.     }
  312.     if {[regexp {^link(.*)$} $vtype "" vtype]} {
  313.     linkVar $name
  314.     # linked variables over-ride differently to normal preferences.
  315.     if {$val != ""} { global $name ; set $name $val }
  316.     }
  317.     set bad 1
  318.     foreach ty ${flag::types} {
  319.     if {[string first $vtype $ty] == 0} {
  320.         set vtype $ty
  321.         set bad 0
  322.         break
  323.     }
  324.     }
  325.     if {$bad} {
  326.     foreach ty {SearchPath Folder Path Mode Colour Color Sig} {
  327.         if {[string first $vtype [string tolower $ty]] == 0} {
  328.         if {[regexp -- "${ty}\$" $name]} {
  329.             set vtype variable
  330.             set bad 0
  331.             break
  332.         } else {
  333.             error "Type '$vtype' requires the variable's name to end in '$ty'"
  334.         }
  335.         }
  336.     }
  337.     if {$bad} {error "Unknown type '$vtype' in call to newPref"}
  338.     }
  339.     if {$pkg == "global"} {
  340.     switch -- $vtype {
  341.         "flag" {
  342.         lappend allFlags $name
  343.         }
  344.         "variable" {
  345.         lappend allVars $name
  346.         }
  347.         default {
  348.         set flag::type($name) $vtype
  349.         lappend allVars $name
  350.         }
  351.     }
  352.     
  353.     global $name mode global::_varMem
  354.     if {![info exists tclvars] || ([lsearch -exact $tclvars $name] == -1)} {lappend tclvars $name}
  355.     if {[info exists mode] && $mode != ""} {
  356.         global ${mode}modeVars
  357.         if {[info exists $name] && [info exists ${mode}modeVars($name)]} {
  358.         # Don't override an existing mode variable which has been
  359.         # copied into the global namespace; instead just place
  360.         # value in the global cache
  361.         set global::_varMem($name) $val
  362.         } else {
  363.         if {![info exists $name]} {set $name $val} else { set val [set $name] }
  364.         }
  365.     } else {
  366.         if {![info exists $name]} {set $name $val} else { set val [set $name] }
  367.     }
  368.     } else {
  369.     global ${pkg}modeVars mode alpha::changingMode
  370.     if {![info exists modeVars] || ([lsearch -exact $modeVars $name] == -1)} {lappend modeVars $name}
  371.     
  372.     if {![info exists ${pkg}modeVars($name)]} {
  373.         set ${pkg}modeVars($name) $val
  374.     } else {
  375.         set val [set ${pkg}modeVars($name)]
  376.     }
  377.     if {!${alpha::changingMode} && ($mode == $pkg)} {
  378.         global $name global::_varMem
  379.         # Need to load up this global cache for when mode changes!
  380.         if {[info exists $name]} { 
  381.         set global::_varMem($name) [set $name]
  382.         }
  383.         set $name $val
  384.     }
  385.     switch -- $vtype {
  386.         "flag" {
  387.         if {[lsearch -exact $allFlags $name] == -1} {
  388.             lappend allFlags $name
  389.         }
  390.         }
  391.         "variable" {
  392.         lappend allVars $name
  393.         }
  394.         default {
  395.         set flag::type($name) $vtype
  396.         lappend allVars $name
  397.         }
  398.     }
  399.     }
  400.     # handle 'options'
  401.     if {$options != ""} {
  402.     switch -- $vtype {
  403.         "variable" {
  404.         global flag::list
  405.         if {$subopt == ""} { set subopt "item" }
  406.         if {[lsearch -exact "array item index varitem varindex" $subopt] == -1} {
  407.             error "Unknown list element type '$subopt' in call to newPref."
  408.         }
  409.         set flag::list($name) [list $subopt $options]
  410.         }
  411.         "binding" {
  412.         global flag::binding
  413.         if {[mode::exists $pkg]} {
  414.             if {$subopt == ""} { 
  415.             set subopt $pkg
  416.             } else {
  417.             if {$subopt == "global"} { set subopt "" }
  418.             }
  419.         } 
  420.         set flag::binding($name) [list $subopt $options]
  421.         if {$options == 1} { set options $name }
  422.         catch "Bind [keys::toBind $val] [list $options] $subopt"
  423.         }
  424.     }
  425.     }
  426.     # register the 'modify' proc
  427.     if {[string length $pname]} {
  428.     set flag::procs($name) $pname
  429.     }
  430. }
  431.  
  432. ## 
  433.  # -------------------------------------------------------------------------
  434.  # 
  435.  # "alpha::rectifyPackageCount" --
  436.  # 
  437.  #  Returns 1 if count has changed.  Note that we don't check for a 
  438.  #  changed count in 'SystemCode', since users won't install stuff there.
  439.  # -------------------------------------------------------------------------
  440.  ##
  441. proc alpha::rectifyPackageCount {} {
  442.     global HOME file::separator
  443.     # check things haven't changed
  444.     foreach d {Modes Menus Packages} {
  445.     lappend count [llength [glob -nocomplain -dir [file join ${HOME} Tcl ${d}] "*.tcl"]] \
  446.       [llength [glob -nocomplain -dir [file join ${HOME} Tcl ${d}] -types d *]]
  447.     }
  448.     if {![cache::exists index::count[join $count -]]} {
  449.     cache::deletePat index::count*
  450.     cache::create index::count[join $count -]
  451.     return 1
  452.     } else {
  453.     return 0
  454.     }
  455. }
  456.  
  457. proc alpha::checkConfiguration {} {
  458.     global alpha::version alpha::tclversion
  459.     if {![cache::exists index::feature] || (![cache::exists index::mode]) \
  460.       || ([alpha::package versions Alpha] != ${alpha::version}) \
  461.       || ([alpha::package versions AlphaTcl] != ${alpha::tclversion})} {
  462.     set rebuild 1
  463.     # We no longer zap the cache
  464.     if {0} {
  465.         # If there's no package information stored at all, or if Alpha's
  466.         # version number has changed, zap the cache.  This may not be
  467.         # required, but is safer since core-code changes may modify the
  468.         # form of the cache, or change the format of cached menus etc.
  469.         global PREFS
  470.         if {[cache::exists configuration]} {
  471.         # in case we crashed or some other weirdness
  472.         catch {file delete [file join ${PREFS} configuration]}
  473.         # now backup the configuration file
  474.         # Alpha has a bad filesystem bug which can sometimes arise
  475.         # here, so we do this crazy stuff.
  476.         if {[catch {file rename [file join ${PREFS} Cache configuration] \
  477.           [file join ${PREFS} configuration]}]} {
  478.             dialog::alert "You've hit an unfortunate filesystem bug in Alpha.\
  479.               Unfortunately there is no workaround.  Alpha will now forget\
  480.               your globally active features, and some other preferences.\r\
  481.               Sorry!  This will be fixed in Alpha 8.0."
  482.         }
  483.         rm -r [file join ${PREFS} Cache]
  484.         file mkdir [file join ${PREFS} Cache]
  485.         catch {file rename [file join ${PREFS} configuration] \
  486.           [file join ${PREFS} Cache configuration]}
  487.         } else {
  488.         rm -r [file join ${PREFS} Cache]
  489.         file mkdir [file join ${PREFS} Cache]
  490.         }
  491.     }
  492.     } else {
  493.     set rebuild [alpha::rectifyPackageCount]
  494.     }
  495.     return $rebuild
  496. }
  497.  
  498.  
  499.